home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / cmplrtst.lha / sort / qsort.scm < prev    next >
Encoding:
Text File  |  1990-03-27  |  1.8 KB  |  81 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (declare (usual-integrations))
  4.  
  5. (let-syntax ((define-integrable
  6.            (macro (params . body)
  7.          `(begin
  8.             (declare (integrate-operator ,(car params)))
  9.             (define ,(car params)
  10.               (named-lambda ,params
  11.             (declare (integrate ,@(cdr params)))
  12.             ,@body))))))
  13.  
  14. (define (sort obj pred)
  15.   (cond ((pair? obj)
  16.      (vector->list (sort! (list->vector obj) pred)))
  17.     ((vector? obj)
  18.      (sort! (vector-copy obj) pred))
  19.     ((null? obj)
  20.      '())
  21.     (else
  22.      (error "sort: argument should be a list or a vector"))))
  23.  
  24. (define (sort! vec pred)
  25.   (define-integrable (exchange! i j)
  26.     (let ((old (vector-ref vec i)))
  27.       (vector-set! vec i (vector-ref vec j))
  28.       (vector-set! vec j old)))
  29.  
  30.   (define (split a b)
  31.     (cond ((= b (1+ a))
  32.        (if (not (pred (vector-ref vec a)
  33.               (vector-ref vec b)))
  34.            (exchange! a b)))
  35.       ((< a b)
  36.        (let* ((middle (quotient (+ a b) 2))
  37.           (val (vector-ref vec middle)))
  38.  
  39.          (define (split-1-end i j)
  40.            (if (> i b)
  41.            (begin
  42.              (exchange! middle b)
  43.              (split a (-1+ b)))
  44.            (begin
  45.              (split a j)
  46.              (split i b))))
  47.  
  48.          (define (split-1 i j)
  49.            (cond ((> i j)
  50.               (split-1-end i j))
  51.              ((pred (vector-ref vec i) val)
  52.               (split-1 (1+ i) j))
  53.              (else (split-2 i j))))
  54.  
  55.          (define (split-2-end i j)
  56.            (if (< j a)
  57.            (begin
  58.              (exchange! a middle)
  59.              (split (1+ a) b))
  60.            (begin
  61.              (split a j)
  62.              (split i b))))
  63.  
  64.          (define (split-2 i j)
  65.            (cond ((< j i)
  66.               (split-2-end i j))
  67.              ((pred val (vector-ref vec j))
  68.               (split-2 i (-1+ j)))
  69.              (else
  70.               (exchange! i j)
  71.               (split-1 (1+ i) (-1+ j)))))
  72.   
  73.          (split-1 a b)))))
  74.  
  75.   (if (not (vector? vec))
  76.       (error "sort!: argument must be a vector" vec))
  77.  
  78.   (split 0 (-1+ (vector-length vec)))
  79.   vec)
  80.  
  81. ) ;; End of let-syntax